home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / share / perl5 / Mail / Util.pm < prev    next >
Text File  |  2008-07-29  |  3KB  |  150 lines
  1. # Copyrights 1995-2008 by Mark Overmeer <perl@overmeer.net>.
  2. #  For other contributors see ChangeLog.
  3. # See the manual pages for details on the licensing terms.
  4. # Pod stripped from pm file by OODoc 1.05.
  5. use strict;
  6.  
  7. package Mail::Util;
  8. use vars '$VERSION';
  9. $VERSION = '2.04';
  10.  
  11. use base 'Exporter';
  12.  
  13. our @EXPORT_OK = qw(read_mbox maildomain mailaddress);
  14.  
  15. use Carp;
  16. sub Version { our $VERSION }
  17.  
  18. my ($domain, $mailaddress);
  19. my @sendmailcf = qw(/etc /etc/sendmail /etc/ucblib
  20.     /etc/mail /usr/lib /var/adm/sendmail);
  21.  
  22.  
  23. sub read_mbox($)
  24. {   my $file  = shift;
  25.  
  26.     local *FH;
  27.     open FH,'<', $file
  28.     or croak "cannot open '$file': $!\n";
  29.  
  30.     local $_;
  31.     my @mbox;
  32.     my $mail  = [];
  33.     my $blank = 1;
  34.  
  35.     while(<FH>)
  36.     {   if($blank && /^From .*\d{4}/)
  37.         {   push @mbox, $mail if @$mail;
  38.         $mail  = [ $_ ];
  39.         $blank = 0;
  40.     }
  41.     else
  42.         {   $blank = m/^$/ ? 1 : 0;
  43.         push @$mail, $_;
  44.     }
  45.     }
  46.  
  47.     push @mbox, $mail if @$mail;
  48.     close FH;
  49.  
  50.     wantarray ? @mbox : \@mbox;
  51. }
  52.  
  53.  
  54. sub maildomain()
  55. {   return $domain
  56.     if defined $domain;
  57.  
  58.     $domain = $ENV{MAILDOMAIN}
  59.         and return $domain;
  60.  
  61.     # Try sendmail configuration file
  62.  
  63.     my $config = (grep -r, map {"$_/sendmail.cf"} @sendmailcf)[0];
  64.  
  65.     local *CF;
  66.     local $_;
  67.     if(defined $config && open CF, '<', $config)
  68.     {   my %var;
  69.     while(<CF>)
  70.         {   if(my ($v, $arg) = /^D([a-zA-Z])([\w.\$\-]+)/)
  71.             {   $arg =~ s/\$([a-zA-Z])/exists $var{$1} ? $var{$1} : '$'.$1/eg;
  72.         $var{$v} = $arg;
  73.         }
  74.     }
  75.     close CF;
  76.     $domain = $var{j} if defined $var{j};
  77.     $domain = $var{M} if defined $var{M};
  78.  
  79.         $domain = $1
  80.             if $domain && $domain =~ m/([A-Za-z0-9](?:[\.\-A-Za-z0-9]+))/;
  81.  
  82.     return $domain
  83.         if defined $domain && $domain !~ /\$/;
  84.     }
  85.  
  86.     # Try smail config file if exists
  87.  
  88.     if(open CF, '<', "/usr/lib/smail/config")
  89.     {   while(<CF>)
  90.         {   if( /\A\s*hostnames?\s*=\s*(\S+)/ )
  91.             {   $domain = (split /\:/,$1)[0];
  92.         last;
  93.         }
  94.     }
  95.     close CF;
  96.  
  97.     return $domain
  98.         if defined $domain;
  99.     }
  100.  
  101.     # Try a SMTP connection to 'mailhost'
  102.  
  103.     if(eval {require Net::SMTP})
  104.     {   foreach my $host (qw(mailhost localhost))
  105.         {   # hosts are local, so short timeout
  106.             my $smtp = eval { Net::SMTP->new($host, Timeout => 5) };
  107.         if(defined $smtp)
  108.             {   $domain = $smtp->domain;
  109.         $smtp->quit;
  110.         last;
  111.         }
  112.     }
  113.     }
  114.  
  115.     # Use internet(DNS) domain name, if it can be found
  116.     $domain = Net::Domain::domainname()
  117.         if !defined $domain && eval {require Net::Domain};
  118.  
  119.     $domain ||= "localhost";
  120. }
  121.  
  122.  
  123. sub mailaddress()
  124. {  return $mailaddress
  125.        if defined $mailaddress;
  126.  
  127.     # Get user name from environment
  128.     $mailaddress = $ENV{MAILADDRESS};
  129.  
  130.     unless($mailaddress || $^O ne 'MacOS')
  131.     {   require Mac::InternetConfig;
  132.  
  133.         no strict;
  134.     Mac::InternetConfig->import;
  135.     $mailaddress = $InternetConfig{kICEmail()};
  136.     }
  137.  
  138.     $mailaddress ||= $ENV{USER} || $ENV{LOGNAME} || eval {getpwuid $>}
  139.                  ||  "postmaster";
  140.  
  141.     # Add domain if it does not exist
  142.     $mailaddress .= '@' . maildomain
  143.     if $mailaddress !~ /\@/;
  144.  
  145.     $mailaddress =~ s/(^.*<|>.*$)//g;
  146.     $mailaddress;
  147. }
  148.  
  149. 1;
  150.